home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / util / walk-ast.scm < prev   
Encoding:
Text File  |  1994-09-27  |  6.9 KB  |  112 lines  |  [TEXT/CCL2]
  1. at takes a type descriptor as an argument.  This is used to
  2. ;;; do the lookup of the walker function for the given type.
  3. ;;; If no explicit accessor is provided, one will be created.  It will
  4. ;;; use a hash table keyed off the type names to store the walker functions.
  5. ;;; In either case, the mapping between the walker name and accessor is
  6. ;;; stored in the hash table ast-walker-table.
  7.  
  8. (define ast-walker-table (make-table))
  9.  
  10. (define-syntax (define-walker walk-type . maybe-accessor)
  11.   (let ((accessor-name  (if (null? maybe-accessor)
  12.                 (symbol-append walk-type '-walker)
  13.                 (car maybe-accessor))))
  14.     (setf (table-entry ast-walker-table walk-type) accessor-name)
  15.     `(begin
  16.        ,@(if (null? maybe-accessor)
  17.          (let ((accessor-table (symbol-append '* walk-type '-table*)))
  18.            `((define ,accessor-table (make-table))
  19.              (define-syntax (,accessor-name td)
  20.                (list 'table-entry
  21.                  ',accessor-table
  22.                  (list 'td-name td)))))
  23.          '())
  24.        (setf (table-entry ast-walker-table ',walk-type)
  25.          ',accessor-name)
  26.        ',walk-type)))
  27.  
  28. (define-syntax (ast-walker walk-type td)
  29.   (let ((accessor  (table-entry ast-walker-table walk-type)))
  30.     `(,accessor ,td)))
  31.  
  32.  
  33. ;;; This macro dispatches a walker on an object of type ast-node.
  34.  
  35. (define-syntax (call-walker walk-type object . args)
  36.   (let ((temp (gensym "OBJ")))
  37.     `(let ((,temp ,object))
  38.        (funcall (or (ast-walker ,walk-type (struct-type-descriptor ,temp))
  39.             (walker-not-found-error ',walk-type ,temp))
  40.         ,temp
  41.         ,@args))
  42.     ))
  43.  
  44. (define (walker-not-found-error walk-type object)
  45.   (error "There is no ~a walker for structure ~A defined."
  46.      walk-type (td-name (struct-type-descriptor object))))
  47.  
  48.  
  49.  
  50. ;;; Define an individual walker for a particular type.  The body should
  51. ;;; return either the original object or a replacement for it.
  52.  
  53. (define-syntax (define-walker-method walk-type type args . body)
  54.   (let ((function-name  (symbol-append walk-type '- type)))
  55.     `(begin
  56.        (define (,function-name ,@args) ,@body)
  57.        (setf (ast-walker ,walk-type (lookup-type-descriptor ',type))
  58.          (function ,function-name))
  59.        ',function-name)))
  60.  
  61.  
  62.  
  63. ;;;=====================================================================
  64. ;;; Support for default walker methods
  65. ;;;=====================================================================
  66.  
  67. ;;; Two kinds of walkers are supported: a collecting walker, which
  68. ;;; walks over a tree collecting some sort of returned result while
  69. ;;; not changing the tree itself, and a rewriting walker which maps
  70. ;;; ast to ast.
  71.  
  72. ;;; The basic template for a collecting walk is:
  73. ;;; (define-walker-method walk-type type (object accum)
  74. ;;;   (sf1 (sf2 object ... (sfn accum)))
  75. ;;; where sfi = slot function for the ith slot.
  76. ;;;
  77. ;;; The slot-processor should be the name of a macro that is called with four
  78. ;;; arguments:  a slot descriptor, the object type name, a form 
  79. ;;; representing the object being traversed, and a form representing the 
  80. ;;; accumulated value.
  81. ;;; If the slot does not participate in the walk, this last argument should
  82. ;;; be returned unchanged as the expansion of the macro.
  83.  
  84. (define-syntax (define-collecting-walker-methods walk-type types
  85.          slot-processor)
  86.   `(begin
  87.      ,@(map (lambda (type)
  88.           (make-collecting-walker-method walk-type type slot-processor))
  89.         types)))
  90.  
  91. (define (make-collecting-walker-method walk-type type slot-processor)
  92.   `(define-walker-method ,walk-type ,type (object accum)
  93.      object   ; prevent possible unreferenced variable warning
  94.      ,(make-collecting-walker-method-body
  95.        'accum
  96.        type
  97.        (td-slots (lookup-type-descriptor type))
  98.        slot-processor)))
  99.  
  100. (define (make-collecting-walker-method-body base type slots slot-processor)
  101.   (if (null? slots)
  102.       base
  103.       `(,slot-processor ,(car slots) ,type object 
  104.          ,(make-collecting-walker-method-body
  105.              base type (cdr slots) slot-processor))))
  106.  
  107.  
  108.  
  109. ;;; A rewriting walker traverses the ast modifying various subtrees.
  110. ;;; The basic template here is:
  111. ;;; (define-walker-method walker type (object . args)
  112. ;;;   (setf (slot1 object) (walk (slot1 ob